home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
FishMarket 1.0
/
FishMarket v1.0.iso
/
fishies
/
501-525
/
disk_503
/
pcq
/
pcq12a.lzh
/
Examples
/
WhichFont.p
< prev
next >
Wrap
Text File
|
1990-07-18
|
8KB
|
252 lines
Program WhichFont;
{
sample program that asks AvailFonts() to make a list of the fonts
that are available and makes a list of them, then opens a separate
window and prints a description of the various attributes that can
be applied to the fonts, in the font itself. Notice that not all
fonts accept all attributes (garnet9 for example, won't underline)
Also note, if you run this, that not all fonts are as easily readable
in the various bold and italicized modes.... this rendering is done
in a fixed manner by software and the fonts were not necessarily
designed to accept it. It is always best to have a font that has
been designed with a bold or italic characteristic built-in rather
than try to bold-ize or italicize and existing plain font.
}
{ Author: Rob Peck 10/28/85 }
{ Converted to PCQ Pascal 2/7/90. For how little it does, this
program sure does use a lot of include files... }
{$I "Include:Graphics/Graphics.i"}
{$I "Include:Graphics/Text.i"}
{$I "Include:Graphics/Pens.i"}
{$I "Include:Libraries/DiskFont.i"}
{$I "Include:Intuition/Intuition.i"}
{$I "Include:Utils/StringLib.i"}
{$I "Include:Exec/Libraries.i"}
{$I "Include:Exec/Interrupts.i"}
{$I "Include:Graphics/RastPort.i"}
{$I "Include:Libraries/DOS.i"}
Const
AFTABLESIZE = 2000;
Var
af : AvailFontPtr;
afh : AvailFontsHeaderPtr;
tf : TextFontPtr;
ta : TextAttr;
Const
nw : NewWindow = (
10, 10, { starting position (left,top) }
620,40, { width, height }
-1,-1, { detailpen, blockpen }
CLOSEWINDOW_f, { flags for idcmp }
WINDOWCLOSE + WINDOWDEPTH + WINDOWSIZING + WINDOWDRAG +
SIMPLE_REFRESH + ACTIVATE + GIMMEZEROZERO,
{ window gadget flags }
Nil, { pointer to 1st user gadget }
Nil, { pointer to user check }
"Text Font Test", { title }
Nil, { pointer to window screen }
Nil, { pointer to super bitmap }
100,45, { min width, height }
640,200, { max width, height }
WBENCHSCREEN_f);
Var
w : WindowPtr;
rp : RastPortPtr;
Const
text_styles : Array [0..6] of Short = (
FS_NORMAL, FSF_UNDERLINED, FSF_ITALIC, FSF_BOLD,
FSF_ITALIC + FSF_BOLD, FSF_BOLD + FSF_UNDERLINED,
FSF_ITALIC + FSF_BOLD + FSF_UNDERLINED);
text_desc : Array [0..6] of String = (
" Normal Text", " Underlined", " Italicized", " Bold",
" Bold Italics", " Bold Underlined",
" Bold Italic Underlined");
text_length : Array [0..6] of Short = (12, 11, 11, 5, 13, 16, 23);
pointsize : Array [0..31] of String = (
" 0"," 1"," 2"," 3"," 4"," 5"," 6"," 7"," 8"," 9",
"10","11","12","13","14","15","16","17","18","19",
"20","21","22","23","24","25","26","27","28","29",
"30","31");
Var
fontname : Array [0..40] of Char;
dummy : Array [0..100] of Char; { provided for string length calculation }
outst : Array [0..100] of Char;
{ build something to give to Text, see note in
the program body about algorithmically
generated styles
}
var
fonttypes : Byte;
i,j,k,m : Integer;
afsize : Short;
style : Short;
sEnd : Short; { Numerical position of end of string terminator }
styleresult : Short;
Procedure Leave(r : Integer);
begin
Exit(20);
end;
Function IsCopy(af : AvailFontPtr) : Boolean;
begin
IsCopy := (((af^.af_Attr.ta_Flags and FPF_REMOVED) <> 0) or
((af^.af_Attr.ta_Flags and FPF_REVPATH) <> 0) or
(((af^.af_Type and AFF_MEMORY) <> 0) and
((af^.af_Attr.ta_Flags and FPF_DISKFONT) <> 0)));
{ do nothing if font is removed, or if
font designed to be rendered rt->left
(simple example writes left to right)
or if font both on disk and in ram,
don't list it twice. }
{ AvailFonts performs an AddFont to the system list;
if run twice, you get two entries, one of "af_Type 1" saying
that the font is memory resident, and the other of "af_Type 2"
saying the font is disk-based. The third part of the
if-statement lets you tell them apart if you are scanning
the list for unique elements; it says "if its in memory and
it is from disk, then don't list it because you'll find another
entry in the table that says it is not in memory, but is on disk.
(Another task might have been using the font as well, creating
the same effect).
}
end;
Begin
DiskFontBase := OpenLibrary("diskfont.library",0);
if DiskFontBase = Nil then
leave(-4);
GfxBase := OpenLibrary("graphics.library",0);
if GfxBase = Nil then
leave(-3);
tf := Nil; { no font currently selected }
afsize := AFTABLESIZE; { show how large a buffer is available }
fonttypes := $ff; { show us all font types }
w := OpenWindow(Adr(nw));
if w <> nil then begin
rp := w^.RPort;
afh := AvailFontsHeaderPtr(AllocString(afsize));
Move(rp, 10, 20);
GText(rp, "Searching for fonts",19);
j := AvailFonts(afh, afsize, fonttypes);
for m := 0 to 1 do begin
SetAPen(rp,1);
if m = 0 then
SetDrMd(rp,JAM1)
else
SetDrMd(rp,JAM1+INVERSVID);
{ now print a line that says what font and what style it is }
for j := 0 to Pred(afh^.afh_NumEntries) do begin
af := Adr(afh^.afh_AF[j]);
strcpy(String(Adr(FontName)), af^.af_Attr.ta_Name);
{ copy name into build-name area }
{ already has ".font" onto end of it }
ta.ta_Name := String(Adr(fontname));
ta.ta_YSize := af^.af_Attr.ta_YSize; { ask for this size }
ta.ta_Style := af^.af_Attr.ta_Style; { ask for designed style }
ta.ta_Flags := FPF_ROMFONT + FPF_DISKFONT +
FPF_PROPORTIONAL + FPF_DESIGNED;
{ accept it from anywhere it exists }
style := ta.ta_Style;
if not IsCopy(af) then begin
tf := OpenDiskFont(Adr(ta));
if tf <> Nil then begin
SetFont(rp, tf);
for k := 0 to 6 do begin
style := text_styles[k];
styleresult := SetSoftStyle(rp,style,255);
SetRast(rp,0); { erase any previous text }
Move(rp,10,20); { move down a bit from the top }
strcpy(Adr(outst), af^.af_Attr.ta_Name);
strcat(Adr(outst), " ");
strcat(Adr(outst), PointSize[af^.af_Attr.ta_YSize]);
strcat(Adr(outst), " Points, ");
strcat(Adr(outst), text_desc[k]);
GText(rp,Adr(outst),strlen(Adr(outst)));
{
Have to build the string before sending it out to
text IF ALGORITHMICALLY GENERATING THE STYLE since
the kerning and spacing tables are based on the
vanilla text, and not the algorithmically generated
style. If you send characters out individually,
it is possible that the enclosing rectangle of
a later character will chop off the trailing edge
of a preceding character
}
{ **************************************************
This alternate method, when in INVERSVID, exhibits the
problem described above.
GText(rp,af^.af_Attr.taName,strlen(af^.af_Attr.taName));
GText(rp," ",2);
GText(rp,pointsize[af^.af_Attr.taYSize],2);
GText(rp," Points, ",9);
GText(rp,text_desc[k],text_length[k]);
************************************************** }
Delay(40); { use the DOS time delay function
specifies 60ths of a second }
if GetMsg(w^.UserPort) <> Nil then begin
CloseFont(tf);
Forbid;
repeat until GetMsg(w^.UserPort) = Nil;
CloseWindow(w);
Permit;
CloseLibrary(DiskfontBase);
CloseLibrary(GfxBase);
exit(0);
end;
end;
CloseFont(tf); { close the old one }
{ NOTE:
Even though you close a font, it doesn't get unloaded
Memory unless a font with a different name is specified
for loading. In this case, any font (except the topaz
set) which has been closed can have its memory area
freed and it will no longer be accessible. If you close
a font to go to a different point-size, it will NOT cause
a disk-access.
ALSO NOTE:
Loading a font loads ALL of the point
sizes contained in that font's directory!!!!
}
end;
end;
end;
end;
CloseWindow(w);
end;
CloseLibrary(DiskfontBase);
CloseLibrary(GfxBase);
end.